home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
tpb4_src.zip
/
CORE2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-09-13
|
22KB
|
865 lines
{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault
Last modified :: 9-13-88 7:09 pm
}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I+} {I/O checking on}
{$N-} {No numeric coprocessor}
Unit Core2;
Interface
Uses
TPCrt, Globals, TPSTRING, Core1,
KeyStuff, BinEd, Sort;
procedure GetStr(var inpstr : StrStd;
var ch : Char;
maxlen : Integer;
mode : Str10);
procedure pause;
function prompt(pr : StrStd; len : Integer; mode : Str10) : StrStd;
function ask(pr : StrPr; mode : Char) : Boolean;
function test_bit(var num; bit_num : Integer) : Boolean;
procedure set_bit(var target; bit_num : Integer);
procedure clear_bit(var target; bit_num : Integer);
procedure FindSect(var req : DosFileName; var drive : Str3; var found : Boolean);
function min(x, y : LongInt) : Integer;
function max(x, y : Integer) : Integer;
function intstr(n, w : Integer) : Str10;
function strint(st : Str10) : Integer;
function FormTAD(t : tad_array) : StrTAD;
procedure send_time(size : Integer; var mm, ss : Integer);
procedure timer(var time_on, time_left : Integer);
procedure mesg_insert(TypMsg : Byte);
procedure list(ch : Char);
procedure Write_status_line;
procedure caps_to_mixed(var full_name : StrStd);
procedure ScrollOn;
procedure ScrollOff;
procedure NewExit;
function greg_to_jul(day, mon, yr : Integer) : Real;
procedure check_time;
procedure UserEventCheck(EventNo, KbdFlagInfo : Word);
procedure put_recs;
procedure get_recs;
function less_rec(var x, y : sort_typ) : Boolean;
{==========================================================================}
Implementation
procedure GetStr(var inpstr : StrStd;
var ch : Char;
maxlen : Integer;
mode : Str10);
{ Get a valid input string from the user }
type
charset = set of Char;
const
editset : charset = [BS, RUB, CAN, TAB];
termset : charset = [LF, CR, ETX];
dispset : charset = [' '..'~'];
var
auto, echo, shift_lock, Wrap, question, hard : Boolean;
i, len, cursor : Integer;
begin
if user_rec.columns < maxlen then
maxlen := user_rec.columns;
auto := (Pos('A', mode) > 0); { Line complete when full }
echo := (Pos('E', mode) > 0); { Display characters on entry }
shift_lock := (Pos('S', mode) > 0); { Make all characters upper case }
Wrap := (Pos('W', mode) > 0);
question := (Pos('?', mode) > 0); { Force inpstr := '?' when encountered }
hard := (Pos('H', mode) > 0);
auto := auto or Wrap; { Wrap forces auto on }
len := Length(inpstr);
cursor := Succ(len);
if echo and (cursor > 0) then
Write(com, inpstr);
repeat
input_time := timeout*18.2;
time_count := 0;
repeat
ch := GetChar;
until (not Online) or (ch <> NUL) or (input_timeout);
if shift_lock then
ch := Upcase(ch);
case ch of
TAB :
repeat
if echo then
Write(com, ' ');
Inc(cursor);
Insert(' ', inpstr, cursor)
until (0 = cursor mod 5) or (cursor >= maxlen);
RUB, BS :
if cursor > 1 then
begin
Write(com, BS, ' ', BS);
cursor := Pred(cursor);
Delete(inpstr, cursor, 1)
end;
CAN :
while cursor > 1 do
begin
Write(com, BS, ' ', BS);
cursor := Pred(cursor);
Delete(inpstr, cursor, 1)
end;
^A :
while cursor > 1 do
begin
if echo then
Write(com, BS);
cursor := Pred(cursor)
end;
^S :
if cursor > 1 then
begin
if echo then
Write(com, BS);
cursor := Pred(cursor)
end;
^D :
if cursor <= Length(inpstr) then
begin
if echo then
Write(com, inpstr[cursor]);
Inc(cursor)
end;
^F :
while cursor <= Length(inpstr) do
begin
if echo then
Write(com, inpstr[cursor]);
Inc(cursor)
end;
^G :
if cursor <= Length(inpstr) then
Delete(inpstr, cursor, 1);
else
if (ch in dispset) and ((len < maxlen) or auto) then
begin
if echo then
Write(com, ch)
else
Write(com, '.');
if (ch = '?') and question and (len = 1) then
begin
inpstr := ch;
ch := CR
end
else
begin
Insert(ch, inpstr, cursor);
Inc(cursor)
end
end
end;
len := Length(inpstr)
until (not Online) or (ch in termset) or ((len >= maxlen) and auto);
next_inpstr := '';
if Wrap and (len >= maxlen) then
begin
while (inpstr[len] <> ' ') and (len > 1) do
len := Pred(len);
if len > 1 then
begin
if echo then
begin
for i := Succ(len) to Length(inpstr) do
Write(com, BS);
for i := Succ(len) to Length(inpstr) do
Write(com, ' ')
end;
next_inpstr := Copy(inpstr, Succ(len), Length(inpstr));
inpstr := Copy(inpstr, 1, Pred(len))
end;
end
else if hard and (Length(inpstr) > 0) then
inpstr := inpstr+Chr($0D)+Chr($0A);
end;
procedure pause;
{ Pause for user response before continuing }
var
ch : Char;
begin
input_time := timeout*18.2;
time_count := 0;
Write(com, 'Press any key to continue...');
if user_rec.noisy then
Write(com, BEL);
repeat
ch := GetChar;
if (ch = ETX) or (ch = #$0B) or (Upcase(ch) = 'K') or (ch = ESC) then
abort := True;
until (not Online) or (ch <> NUL) or (input_timeout);
Write(com, CR, ' ':28, CR)
end;
function prompt(pr : StrStd; len : Integer; mode : Str10) : StrStd;
{ Prompt user, return string and process multiple command buffer }
type
charset = set of Char;
const
delim_set : charset = [';', ' ', ','];
var
i, J : Integer;
reply, Buffer : StrStd;
t : tad_array;
begin
reply := '';
Buffer := '';
ch := ' ';
if (not mult_cmds) or (Pos('L', mode) > 0) then {L for literal}
begin
Write(com, pr);
if Pos('M', mode) > 0 then
Write(com, ' [press "?" for menu]');
Write(com, '> ');
if user_rec.noisy then
Write(com, BEL);
GetStr(Buffer, ch, len, mode);
end
else
Buffer := Cmd_Queue; {feed in from queue}
if Pos('L', mode) = 0 then
begin {not literal, process mult. commands}
i := 0;
J := 0;
repeat
Inc(i);
if (Pos('N', mode) > 0) and (Buffer[i] = ' ') then
Inc(i);
if Buffer[i] in delim_set then
J := i;
until (i >= Length(Buffer)) or (Buffer[i] in delim_set);
if J > 0 then
begin
mult_cmds := True;
reply := Copy(Buffer, 1, J-1); {get command from buffer}
Delete(Buffer, 1, J); {remove cmd and delimeter}
if Buffer = '' then
begin
mult_cmds := False;
Cmd_Queue := '';
end
else
Cmd_Queue := Buffer; {save balance for next command}
if reply = '' then
reply := ' ';
if macro_in_progress and (reply = Chr(13)) then
reply := ' ';
end
else
begin
mult_cmds := False;
Cmd_Queue := '';
reply := Buffer; {for single commands}
if reply = '' then
reply := ' '; {so we wont bomb ch assignments}
if macro_in_progress and (reply = Chr(13)) then
reply := ' ';
end;
if macro_in_progress then
Delay(500);
end {not literal}
else
begin {literal}
reply := Buffer;
mult_cmds := False;
Cmd_Queue := '';
end;
WriteLn(com);
prompt := reply;
end; {prompt}
function ask(pr : StrPr; mode : Char) : Boolean;
{ Ask yes-or-no question and return TRUE for 'Y', FALSE otherwise }
var
ch : Char;
temp : string[1];
begin
if user_rec.noisy then
Write(com, BEL);
repeat
if mode = 'N' then
temp := Copy(prompt(pr+' [y/N] ? >', 1, 'ES'), 1, 1)
else
temp := Copy(prompt(pr+' [Y/n] ? >', 1, 'ES'), 1, 1);
ch := temp[1];
until (ch in ['Y', 'N', ' ']) or (not Online);
if ch = 'Y' then
ask := True
else if ch = 'N' then
ask := False
else if mode = 'Y' then
ask := True
else
ask := False;
end;
function test_bit(var num; bit_num : Integer) : Boolean;
var
subject : Integer absolute num;
dummy : Integer;
begin
dummy := subject;
dummy := dummy shr bit_num;
if Odd(dummy) then
test_bit := True
else
test_bit := False;
end;
procedure set_bit(var target; bit_num : Integer);
var
subject : Integer absolute target;
mask : Integer;
begin
mask := 1 shl bit_num;
subject := subject or mask;
end;
procedure clear_bit(var target; bit_num : Integer);
var
subject : Integer absolute target;
mask : Integer;
begin
mask := not(1 shl bit_num);
subject := subject and mask;
end;
procedure FindSect(var req : DosFileName; var drive : Str3; var found : Boolean);
{ Find file section from requested name }
var
This : SectPtr;
sect_count : Integer;
located : Boolean;
begin
This := SectBase;
located := False;
sect_count := 1;
while (not located) and (This <> nil) do
begin
located := (This^.SectName = req) or (strint(req) = sect_count);
if ((not cold) and (not((user_rec.access >= This^.SectAccs) or (test_bit
(user_rec.conf_flags, This^.SectConf))))) then
begin
Dec(sect_count);
located := False
end;
if located then
begin
drive := This^.SectDrive+':\';
req := This^.SectName
end;
This := This^.next;
Inc(sect_count);
end;
found := located;
end;
function min(x, y : LongInt) : Integer;
{ Return minimum of two integers }
begin
if x < y then
min := x
else
min := y
end;
function max(x, y : Integer) : Integer;
{ Return greater of two integers }
begin
if x > y then
max := x
else
max := y
end;
function intstr(n, w : Integer) : Str10;
{ Return a string value (width 'w')for the input integer ('n') }
var
st : Str10;
begin
Str(n:w, st);
intstr := st
end;
function strint(st : Str10) : Integer;
{ Convert string to integer }
var
x, code : Integer;
begin
if st[1] = '+' then
Delete(st, 1, 1);
if st = '' then
code := 1
else
Val(st, x, code);
if code = 0 then
strint := x
else
strint := 0 { Error, return with 0 }
end;
function FormTAD(t : tad_array) : StrTAD;
{ Build printable string of current time and date }
const
day : array[0..6] of string[6] = ('Sun', 'Mon', 'Tues', 'Wednes', 'Thurs', 'Fri', 'Satur');
month : array[1..12] of string
[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
var
i : Integer;
line : StrTAD;
function zeller(day, month, year : Integer) : Integer;
{ Compute the day of the week using Zeller's Congruence }
var
century : Integer;
begin
if month > 2 then
month := month-2
else
begin
month := month+10;
year := Pred(year)
end;
century := year div 100;
year := year mod 100;
zeller := (day-1+((13*month-1) div 5)+(5*year div 4)+century div 4-2*century+1) mod 7
end;
begin
if (t[1] in [0..59]) and (t[2] in [0..23]) then
line := intstr(t[2], 2)+':'+intstr(t[1], 2)
else
line := '';
for i := 1 to Length(line) do
if line[i] = ' ' then
line[i] := '0';
if (t[3] in [1..31]) and (t[4] in [1..12]) and (t[5] in [0..99]) then
FormTAD := line+' '+day[zeller(t[3], t[4], 1900+t[5])]+'day '+intstr(t[3],
2)+'-'+month[t[4]]+'-'+intstr(t[5], 2)
else
FormTAD := 'No Date'
end;
procedure send_time(size : Integer; var mm, ss : Integer);
{ Compute the file transfer time }
var
tr_time : Real;
begin
tr_time := size*23.5/rate; { Factor is empirically derived }
mm := Trunc(tr_time);
ss := Round(60.0*Frac(tr_time))
end;
procedure timer(var time_on, time_left : Integer);
{ Compute the time on and the time remaining to the current user }
var
t : tad_array;
give_extra : Boolean;
begin
GetTAD(t);
give_extra := False;
time_on := 60*(t[2]-login_t[2])+t[1]-login_t[1];
if time_on < 0 then
time_on := time_on+1440;
time_left := user_rec.limit+extra_time-time_on-user_rec.time_today;
if extra_time_sw then
begin
if ExtraTimeStart < ExtraTimeStop then
begin
if (t[2] > ExtraTimeStart) and (t[2] < ExtraTimeStop) then
give_extra := True;
end
else
begin
if (t[2] > ExtraTimeStart) and (t[2] < ExtraTimeStop+24) then
give_extra := True;
if (t[2] < ExtraTimeStart) and (t[2] < ExtraTimeStop) then
give_extra := True;
end;
if give_extra then
time_left := time_left+extra_time_val;
end;
if cmd_tail and (strint(ParamStr(1)) <> 99) and
(strint(ParamStr(1)) <> 98)
then
if time_left > (time_to_event-time_on) then
time_left := (time_to_event-time_on);
end;
procedure mesg_insert(TypMsg : Byte);
{ Insert message into linked list }
var
This : MesgPtr;
begin
New(This);
if MesgBase = nil then
MesgBase := This
else
MesgLast^.next := This;
MesgLast := This;
MesgLast^.MesgNo := summ_rec.num;
MesgLast^.SummLoc := Pred(FilePos(summ_file));
MesgLast^.TypMsg := TypMsg;
MesgLast^.next := nil
end;
procedure list(ch : Char);
{ List a portion of the system message file }
var
line_count : Integer;
This : SysmPtr;
begin
This := SysmBase;
while (This <> nil) and (This^.key <> ch) do
This := This^.next;
if This^.key = ch then
begin
WriteLn(com);
Seek(sysm_file, Succ(This^.loc));
Read(sysm_file, sysm_rec);
line_count := 0;
if ch <> 'B' then
abort := False;
while (not brk) and (not EoF(sysm_file)) and (sysm_rec[1] <> ':') do
begin
WriteLn(com, sysm_rec);
Read(sysm_file, sysm_rec);
if (user_rec.lines <> 99) and (ch <> 'W') and (ch <> 'F') then
begin
Inc(line_count);
if line_count mod user_rec.lines = 0 then
pause
end
end
end
end;
procedure Write_status_line;
var
Str : StrTAD;
date : tad_array;
begin
date := user_rec.laston;
Str := intstr(date[4], 2)+'/'+intstr(date[3], 2)+'/'+intstr(date[5], 2);
putstat(user_rec.fn+' '+user_rec.ln+' '+user_rec.cy+', '+user_rec.st+' Phone: '+user_rec.ph
, ' Last on: '+Str+' Access: '+intstr(user_rec.access,
1)+' On today: '+intstr((time_on+user_rec.time_today),
1)+' Time Limit: '+intstr(user_rec.limit, 1)+' '+intstr(rate, 1)+' Baud');
end;
procedure caps_to_mixed(var full_name : StrStd);
var
i, temp : Integer;
begin
for i := 2 to Length(full_name) do
if full_name[Pred(i)] <> Chr($20) then
full_name[i] := LoCase(full_name[i]);
temp := Pos(' Mc', full_name);
if temp <> 0 then
full_name[temp+3] := Upcase(full_name[temp+3]);
end;
procedure ScrollOn;
begin
if fconsole then
begin
Assign(lst, 'CON');
Rewrite(lst);
Write(lst, #27, '[>9;23z');
Close(lst);
end
else
ClrScr;
end;
procedure ScrollOff;
begin
if fconsole then
begin
Assign(lst, 'CON');
Rewrite(lst);
Write(lst, #27, '[>9;25z');
Close(lst);
end;
end;
{$F+}
procedure NewExit; {$F-}
var
LogStr : string[72];
begin
SetSect(HomName);
Assign(temp_file, 'TPBUP.BB#');
Erase(temp_file);
if ErrorAddr <> nil then
begin
LogStr := ' @ '+HexPtr(ErrorAddr);
log(10, LogStr);
Str(ExitCode, LogStr);
LogStr := 'Runtime '+LogStr;
log(10, LogStr);
ErrorAddr := nil;
mdhangup;
end;
ExitCode := NetMsgEntr+EchoMsgEntr;
ExitProc := ExitSave;
end { NewExit } ;
function greg_to_jul(day, mon, yr : Integer) : Real;
{ Convert from Gregorian date to Julian }
var
i : Integer;
begin
i := (mon-14) div 12;
greg_to_jul := day-32075+367*(mon-2-12*i) div 12-3*(yr+6800+i) div 400+365.25*(yr+6700+i)
end;
procedure check_time;
{checks time on system and time left}
begin
timer(time_on, time_left);
if time_left <= 0 then
begin
WriteLn(com, 'Access time expired. Please call back tomorrow.', BEL, BEL, BEL);
Delay((9600 div rate)*100);
remote_online := False;
mdhangup;
end
else if (time_left <= 5) and (time_left <> last_time_left) then
begin
WriteLn(com, 'Less than ', time_left, ' minutes of access time left.', BEL);
last_time_left := time_left;
WriteLn(com);
end;
end;
{$F+}
procedure UserEventCheck(EventNo, KbdFlagInfo : Word);
{Background process called at every keypressed check}
{This routine performs automatic word wrap if needed}
const
LastWhereX : Integer = 0;
overflow : string = '';
var
next_inpstr, CharStr : string;
ThisWhereX, i : Integer;
begin {UserEventCheck}
if overflow <> '' then
begin
next_inpstr := StuffKey(overflow);
overflow := next_inpstr;
end
else
begin
ThisWhereX := WhereX;
if (ThisWhereX = 76) and (ReadCharAtCursor = ' ') then
if ThisWhereX > LastWhereX then
begin
FlushKey;
i := 0;
CharStr := LeftArrow;
repeat
Inc(i);
next_inpstr := StuffKey(CharStr);
if next_inpstr <> '' then
overflow := overflow+next_inpstr;
GoToXY(Pred(WhereX), WhereY);
until ReadCharAtCursor = ' ';
if i < 2 then
next_inpstr := CR
else
next_inpstr := CR+DelKey+EndKey;
next_inpstr := StuffKey(next_inpstr);
if next_inpstr <> '' then
overflow := overflow+next_inpstr;
end;
LastWhereX := ThisWhereX;
if WhereY <> 2 then
FastWrite(' '+DispName, 2, 47, 13);
end;
end; {UserEventCheck}
procedure put_recs;
begin
Assign(sort_file, 'SORT.TMP');
Reset(sort_file);
with sort_rec do
begin
while (not EOF(sort_file)) do
begin
ReadLn(sort_file, first);
ReadLn(sort_file, second);
SortRelease(sort_rec);
end;
end;
Close(sort_file);
Erase(sort_file);
end;
procedure get_recs;
begin
while (not SortEOS) do
begin
SortReturn(sort_rec);
with sort_rec do
begin
WriteLn(dir_file, first);
WriteLn(dir_file, second);
WriteLn(dir_file);
end;
end;
end;
function less_rec(var x, y : sort_typ) : Boolean;
begin
less_rec := ((x.first) < (y.first))
end;
{$F-}
end. { of CORE1.PAS }